;;; Copyright © 2016 Eric Bavier <bavier@member.fsf.org>
;;;
;;; This program is free software.  You may run, copy, modify, and
;;; redistribute it under the terms of the GNU General Purpose License
;;; (GPL) version 3, or any later version.

;;; Derived (pun intended) from Matt Might, Dacid Darais, and Daniel
;;; Spiewak's paper "Parsing with Derivatives, A Functional Pearl" ACM
;;; 978-1-4503-086-6/11/09

(define-module (derivative language regular)
  #:use-module (ice-9 match)
  #:use-module (derivative language)
  #:export (alt cat rep

	    δ nullable?
	    D derivative
	    recognize?

	    ;; test/example languages
	    xyz-lang
	    x-lang
	    ab-lang
	    phone-lang))

(define-syntax alt
  (syntax-rules ()
    ((_) 'empty)
    ((_ L) L)
    ((_ L L* ...)
     ((@@ (derivative language) make-alt) L (alt L* ...)))))

(define-syntax cat
  (syntax-rules ()
    ((_) 'eps)
    ((_ L) L)
    ((_ L L* ...)
     ((@@ (derivative language) make-cat) L (cat L* ...)))))

(define-syntax rep
  (syntax-rules ()
    ((_) 'empty)
    ((_ L) ((@@ (derivative language) make-rep) L))))

(define (δ language)
  (match language
    ('empty #f)
    ('eps #t)
    ((? char?) #f)
    (($ <rep> _) #t)
    (($ <alt> L L') (or (δ L) (δ L')))
    (($ <cat> L L') (and (δ L) (δ L')))))
(define nullable? δ)

(define (D c language)
  (match language
    ('empty 'empty)
    ('eps 'empty)
    ((? char? a) (if (eq? a c)
		     'eps
		     'empty))
    (($ <alt> L L')
     (alt (D c L) (D c L')))
    (($ <cat> (? δ L) L')
     (alt (D c L')
	  (cat (D c L) L')))
    (($ <cat> L L')
     (cat (D c L) L'))
    (($ <rep> L)
     (cat (D c L) language))))
(define derivative D)

(define (recognize? w L)
  "Return #t if W can be recognized as belonging to regular language L,
otherwise #f."
  (match w
    ((? string?)
     (recognize? (string->list w) L))
    (()
     (δ L))
    ((head tail ...)
     (recognize? tail (D head L)))))

;;; Definen some test/example languages

(define xyz-lang
  (cat #\x #\y #\z
       (rep (cat #\x #\y #\z))))
(define x-lang
  (rep #\x))
(define ab-lang
  (let ((a-or-b (alt #\a #\b)))
    (cat a-or-b
	 (rep a-or-b))))
;;; TODO: When hacking, you probably do not want to print the value of
;;; this variable.  The default record printer that is used dumps a
;;; whole ton of text for this language.  If we had a language record,
;;; say <regular-language>, we could set the printer with Guile's (@
;;; (srfi srfi-9 gnu) set-record-type-printer!) to output an
;;; equivalent regex expression instead.
(define phone-lang
  (let* ((digit (alt #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
	 (3digits (cat digit digit digit))
	 (4digits (cat 3digits digit))
	 (intl? (lambda (sep)
		  (alt (cat (alt #\+ 'eps) digit sep)
		       'eps)))
	 (ext? (alt (cat (alt #\x (cat #\e #\x #\t))
			 4digits)
		    'eps)))
    (alt (cat (intl? 'eps) 3digits 3digits 4digits ext?) ;12345678901x2345
	 (cat (intl? 'eps) #\( 3digits #\) 3digits #\- 4digits ext?) ;1(234)567-8901
	 (cat (intl? #\.) 3digits #\. 3digits #\. 4digits ext?) ;1.234.567.8901
	 (cat (intl? #\-) 3digits #\- 3digits #\- 4digits ext?) ;1-234-567-8901
	 )))
